perm filename SC2B.FOR[M11,LCS] blob
sn#439861 filedate 1979-05-08 generic text, type T, neo UTF8
SUBROUTINE MOTIV
DIMENSION LIST(78)
COMMON/VV/LIMIT,V(1) /A/NP(27),XT(27),FRM(80),INVIS(27)
COMMON J,L /INP/INP(1)
1/E/IQ(27),KL,X,ZPAR,KA,INSNUM,NNUM,JJ,JA,ISUB,NFLG
1 ,VX(70),IAMP,K,KN,M,ML,CODE
COMMON/B/MOT,PR,T5,NINS,I,RA,KZY,NWX,INONLY,MX,
1 Y,Z,FNAME,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,NL,RC,W,
1 ZZ,CHN,YY
1 /INTC/LPAR,IPRN,IRETRO,INVRT,ICON,LCNT,
1 JZ,MLX,IZ,JD,LEND,ITMP,LP,ILIT,NLIT,KTMP,IC,IA
1 /REALC/QX,PARENS,BY,ALL,QTS,RAX,RD
1 /BLA/IBLA,KSLA,ISEMI,MINUS,ISTAR,ICOMM,ICOL,IQUES,ILESS,IQT
EQUIVALENCE (VX1,VX(1)),(LIST,FRM(3))
DATA IDOL/'$'/
DO 113 L=1,LEND
K=JD+L
C K IS USED AT 240!!!
JG=INP(K)
IF(JG.NE.MINUS)GO TO 6113
IF(CODE.EQ.-88.)CALL ERR(8)
IRETRO=0
INP(K)=IBLA
GO TO 113
6113 IF(JG.NE.IDOL)GO TO 7113
C '$' IS FOR INVERSIONS IN 'NOTES'
IF(CODE.EQ.-88.)CALL ERR(8)
INVRT=0
GO TO 113
7113 IF(JG.NE.IBLA)GO TO 4113
113 CONTINUE
4113 DO 6361 JMOT=1,LCNT,3
IF(JG.NE.LIST(JMOT))GO TO 6361
VX1=0
DO 40 M=JD+2,LEND
JG=INP(M)
IF(JG.EQ.IBLA)GO TO 40
IF(JG.EQ.KSLA)GO TO 140
IF(JG.EQ.ISEMI)GO TO 140
ML=M
GO TO 240
40 CONTINUE
240 JC=JA
JA=-1
INP(K)=IBLA
CALL SCANR
JA=JC
140 JC=1
KN=LIST(JMOT+1)
M=LIST(JMOT+2)+1
IF(IRETRO.LT.0)GO TO 640
JC=M-1
M=KN-1
KN=JC
JC=-1
IRETRO=-1
640 IF(INVRT.LT.0)GO TO 940
C INVERSIONS NEXT
840 X=V(KN)
IF(X.GT.-9999.)GO TO 841
C CAN'T INVERT A 'P' NUMBER.
Z=X
GO TO 941
841 RB=X
X=ABS(X)+VX1
Z=X
IF(RB.LT.0)Z=-Z
941 V(I)=Z
C FINDS CENTER FOR INVERSION (+TRANSP.)
I=I+1
IZ=IZ+1
C IZ USED FOR INTERNAL TEMPO FEATURE (FIXED 6/78)
KN=KN+JC
IF(V(KN-JC).NE.199.)GO TO 940
C 199. IS NOW NUM. FOR 'R' (REST) 7/78
V(I-1)=199.
GO TO 840
940 Z=V(KN)
IF(Z.LT.-9999.)GO TO 540
C CAN'T INVERT OR TRANSPOSE 'P' NUMBERS.
IF(INVRT.EQ.0)GO TO 440
IF(VX1.EQ.0)GO TO 540
C " @Q N " WHERE N= 1/2 STEPS IN 'NOTES' OR MULT FACTOR IN OTHERS.(NO LIT)
IF(CODE.EQ.-88.)CALL ERR(8)
IF(CODE.EQ.-33.)GO TO 440
V(I)=Z*VX1
GO TO 7361
440 IF(Z.EQ.199.)GO TO 540
C 199. IS NOW NUM. FOR 'R' (REST) 7/78
Y=0
RB=VX1
IF(Z.LT.0)RB=-RB
IF(INVRT.LT.0)GO TO 541
RB=-RB
RC=X
C X IS SET FURTHER BACK.
IF(Z.LT.0)RC=-RC
C THIS STUFF FOR CHORD FEATURE
Y=(RC-Z)*2
541 Z=Z+RB+Y
Y=ABS(Z)
IF(Y.LT.1.OR.Y.GT.108)CALL ERR(8)
C ERROR IF TRANSP. HAS PUSHED A NOTE NUMBER TOO HIGH OR TOO LOW.
V(I)=Z
GO TO 7361
540 V(I)=Z
7361 IF(JC.GT.0)GO TO 543
IF(CODE.NE.-33)GO TO 543
JG=I
IF(V(I).GT.0)GO TO 543
542 Y=V(JG)
V(JG)=V(JG-1)
V(JG-1)=Y
C THIS STUFF FOR CHORD FEATURE
IF(V(JG-2).GT.0)GO TO 543
JG=JG-1
GO TO 542
543 I=I+1
IZ=IZ+1
C IZ USED FOR INTERNAL TEMPO FEATURE (FIXED 6/78)
KN=KN+JC
IF(KN.NE.M)GO TO 940
INVRT=-1
RB=V(I-1)
DO 8361 L=JD,LEND
JG=INP(L)
KN=L
INP(L)=IBLA
IF(JG.EQ.KSLA)GO TO 9361
IF(JG.EQ.IRPRN)IPRN=IPRN+1
IF(JG.NE.ISEMI)GO TO 8361
IAMP=-1
GO TO 9361
8361 CONTINUE
C ABOVE 4 LINES PUT IN 8/76. REPLACE C*********** ↓↓
9361 MLX=L+1
IF(L.GE.LEND)GO TO 93612
C FIX THIS & =IBLA BY CHNGING DO LOOP TO 'GO TO' AT 6721,2722
IF(IAMP.NE.0)GO TO 797
IF(QTS.GE.0)GO TO 797
C GO BACK IF NOT END OF LINE
1773 L=1
C L IS FLAG UPON RETURN (GOES TO 1773 IN OTHER ROUTINE)
RETURN
797 JZ=-1
93612 IF(IAMP.EQ.0)GO TO 93611
C*** JUNE 78 *** BELOW GOES TO CHECK ON INTERNAL TEMPO *****IF(QTS)GO TO 3013
L=3
C L=2 WILL GO TO 9004 UPON RETURN. L=3 GOES TO 2722.
IF(QTS.LT.0)L=2
RETURN
C THESE ARE FOR "LIT" ITEMS
C ******* DO NOT USE '@-' OR '@$' WITH 'LIT', RLIST OR RNOT****
C NO $ WITH FUNC. $ WITH NUMS AND RHY CAN GIVE NEG RESULT -- TRY IT!
93611 IF(KN.NE.LEND)GO TO 7773
L=4
C L=4 GOES TO 7773 IN OTHER ROUTINE
RETURN
7773 JZ=0
IF(IPRN.NE.0)GO TO 1773
C ↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑PICKS UP ' @X)/ ' SITUATION. 22/6/73
L=5
C L=5 GOES TO 236 AT HOME
RETURN
C LAST TIME FOR QUOTES
C JUMPS TO END STRING OF QUOTES
6361 CONTINUE
CALL ERR(0)
C ONLY CAN BE AN ERROR IF WE GET HERE.
RETURN
END
SUBROUTINE X2703
COMMON/VV/LIMIT,V(1) /A/NP(27),XT(27),FRM(80),INVIS(27)
COMMON J,L /DUR/DUR(27) /INP/INP(1)
1/E/IQ(27),KL,X,ZPAR,KA,INSNUM,NNUM,JJ,JA,ISUB,NFLG
1 ,VX(70),IAMP,K,KN,M,ML,CODE
COMMON/B/MOT,PR,T5,NINS,I,RA,KZY,NWX,INONLY,MX,
1 Y,Z,FNAME,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,NL,RC,W,
1 ZZ,CHN,YY
1 /INTC/LPAR,IPRN,IRETRO,INVRT,ICON,LCNT,
1 JZ,MLX,IZ,JD,LEND,ITMP,LP,ILIT,NLIT,KTMP,IC,IA
1 /REALC/QX,PARENS,BY,ALL,QTS,RAX,RD
1 /BLA/IBLA,KSLA,ISEMI,MINUS,ISTAR,ICOMM,ICOL,IQUES,ILESS,IQT
EQUIVALENCE (VX1,VX(1)),(VX2,VX(2)),(VX3,VX(3))
2703 ML=ML+1
VX1=0
VX2=0
VX3=0
IF(N.EQ.IXX)GO TO 2704
INP(ML)=IBLA
INP(ML+1)=IBLA
C WIPES OUT 'EP' IN 'REP'
2704 CALL SCANR
V(IJ)=3.
V(IJ+1)=-66.0
IF(VX1.EQ.32.)VX1=1.
IF(VX1.EQ.0)VX1=LPAR
IF(VX2.EQ.0)VX2=INSNUM-1
V(IJ+2)=VX1+VX2*10000.
KL=VX2
IF(DUR(INSNUM).LT.0)DUR(INSNUM)=DUR(KL)
IF(VX3.EQ.0)RETURN
L=VX3
ML=INSNUM+1
DO 1018 KL=ML,L
IF(LPAR.LE.NP(KL))GO TO 997
IF(LPAR.LT.31)NP(KL)=LPAR
997 IF(DUR(KL).LT.0)DUR(KL)=DUR(INSNUM)
C TO SET DUR WHEN DUPLICATING NOTES THAT END WITH 'END;;'
V(I)=V(I-4)+10000.
V(I+1)=3.
V(I+2)=-66.
V(I+3)=V(I-1)
1018 I=I+4
RETURN
END